home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 1 / Gold Medal Software Volume 1 (Gold Medal) (1994).iso / prog / tpwprog6.arj / TWOBITS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-02  |  3.7 KB  |  146 lines

  1. { twobits.pas -- drawbits.pas modified to display two bitmaps }
  2.  
  3. program TwoBits;
  4.  
  5. uses WinTypes, WinProcs, WObjects;
  6.  
  7. const
  8.  
  9.   bmHeight = 256;   { Height of bitmap }
  10.   bmWidth  = 256;   { Width of bitmap }
  11.  
  12. type
  13.  
  14.   DrawBitsApplication = object(TApplication)
  15.     procedure InitMainWindow; virtual;
  16.   end;
  17.  
  18.   PDrawBitsWindow = ^DrawBitsWindow;
  19.   DrawBitsWindow = object(TWindow)
  20.     TheBitmap: HBitmap;
  21.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  22.     destructor Done; virtual;
  23.     procedure SetupWindow; virtual;
  24.     procedure Paint(PaintDC: HDC;
  25.       var PaintInfo: TPaintStruct); virtual;
  26.   end;
  27.  
  28. var
  29.   SecondHb: HBitmap; 
  30.  
  31. {- Create and draw into a bitmap }
  32. function MakeBitmap(HWindow: HWnd): HBitmap;
  33. var
  34.   Dc, MemDC: HDC;
  35.   OldBitmap, HBits: HBitmap;
  36.   X1, Y1, X2, Y2: Integer;
  37.   SecondMemDC: HDC;
  38.   SecondOldHb: HBitmap; 
  39. begin
  40. {- Create bitmap and fill it with white }
  41.   Dc := GetDC(HWindow);
  42.   MemDC := CreateCompatibleDC(Dc);
  43.   HBits := CreateCompatibleBitmap(Dc, bmWidth, bmHeight);
  44.   OldBitmap := SelectObject(MemDC, HBits);
  45.   PatBlt(MemDC, 0, 0, bmWidth, bmHeight, whiteness);
  46.  
  47. {- Draw outline }
  48.   Rectangle(MemDC, 0, 0, bmWidth, bmHeight);
  49.  
  50. {- Draw concentric circles }
  51.   X1 := 0; Y1 := 0; X2 := bmWidth; Y2 := bmHeight;
  52.   while (X2 >= X1) and (Y2 >= Y1) do
  53.   begin
  54.     Ellipse(MemDC, X1, Y1, X2, Y2);
  55.     X1 := X1 + 10;
  56.     X2 := X2 - 10;
  57.     Y1 := Y1 + 10;
  58.     Y2 := Y2 - 10
  59.   end;
  60.  
  61. {- Draw X through bitmap's center }
  62.   MoveTo(MemDC, 0, 0);
  63.   LineTo(MemDC, bmWidth, bmHeight);
  64.   MoveTo(MemDC, 0, bmHeight);
  65.   LineTo(MemDC, bmWidth, 0);
  66.  
  67.   SecondMemDC := CreateCompatibleDC(MemDC);
  68.   SecondHb := CreateCompatibleBitmap(MemDC, bmWidth, bmHeight);
  69.   SecondOldHb := SelectObject(SecondMemDC, SecondHb);
  70.   StretchBlt(SecondMemDC, 0, 0, bmWidth div 2, bmHeight div 2, MemDC,
  71.     0, 0, bmWidth, bmHeight, srcCopy);
  72.   SelectObject(SecondMemDC, SecondOldHb);
  73.   DeleteDC(SecondMemDC);
  74.  
  75. {- Dispose of supporting objects and return bitmap handle }
  76.   SelectObject(MemDC, OldBitmap);
  77.   DeleteDC(MemDC);
  78.   ReleaseDC(HWindow, Dc);
  79.   MakeBitmap := HBits
  80. end;
  81.  
  82. {----- DrawBitsApplication methods -----}
  83.  
  84. {- Initialize DrawBitsApplication object's window }
  85. procedure DrawBitsApplication.InitMainWindow;
  86. begin
  87.   MainWindow := New(PDrawBitsWindow, Init(nil, 'DrawBits'))
  88. end;
  89.  
  90.  
  91. {----- DrawBitsWindow methods -----}
  92.  
  93. {- Construct DrawBitsWindow object }
  94. constructor DrawBitsWindow.Init(AParent: PWindowsObject;
  95.   ATitle: PChar);
  96. begin
  97.   TWindow.Init(AParent, ATitle)
  98. end;
  99.  
  100. {- Destroy the DrawBitsWindow object }
  101. destructor DrawBitsWindow.Done;
  102. begin
  103.   if TheBitmap <> 0 then DeleteObject(TheBitmap);
  104.   TWindow.Done
  105. end;
  106.  
  107. {- Create the bitmap and store its handle }
  108. procedure DrawBitsWindow.SetupWindow;
  109. begin
  110.   TWindow.SetupWindow;
  111.   TheBitmap := MakeBitmap(HWindow)
  112. end;
  113.  
  114. {- Display the bitmap }
  115. procedure DrawBitsWindow.Paint(PaintDC: HDC;
  116.   var PaintInfo: TPaintStruct);
  117. var
  118.   MemDC: HDC;
  119.   OldBitmap: HBitmap;
  120. begin
  121.   MemDC := CreateCompatibleDC(PaintDC);
  122.   OldBitmap := SelectObject(MemDC, TheBitmap);
  123.   BitBlt(PaintDC, 0, 0, bmWidth, bmHeight, MemDC, 0, 0, srcCopy);
  124.   SelectObject(MemDC, SecondHb);
  125.   BitBlt(PaintDC, 0, 0, bmWidth div 2, bmHeight div 2,
  126.   MemDC, 0, 0, srcCopy); 
  127.   SelectObject(MemDC, OldBitmap);
  128.   DeleteDC(MemDC)
  129. end;
  130.  
  131. var
  132.  
  133.   DrawBitsApp: DrawBitsApplication;
  134.  
  135. begin
  136.   DrawBitsApp.Init('DrawBitsApp');
  137.   DrawBitsApp.Run;
  138.   DrawBitsApp.Done
  139. end.
  140.  
  141.  
  142. {--------------------------------------------------------------
  143.   Copyright (c) 1991 by Tom Swan. All rights reserved.
  144.   Revision 1.00    Date: 2/15/1991
  145. ---------------------------------------------------------------}
  146.